﻿namespace CSP.Applications

module SlitherLink =

    open CSP.Domain
    open CSP.Solving
    open CSP.Extended

    let private domain = ofList [0;1]

    let private keys length width =
        [ for y in 0 .. width do
            for x in 0 .. (length - 1) do
                yield (x,y), (x+1,y)
          for x in 0 .. length do
            for y in 0 .. (width - 1) do
                yield (x,y), (x,y+1) ]

    let private edgesForNode length width x y =
        [ if x >= 1 then yield (x-1,y), (x,y)
          if x <= length - 1 then yield (x,y), (x+1,y)
          if y >= 1 then yield (x,y-1), (x,y)
          if y <= width - 1 then yield (x,y), (x,y+1) ]

    let private edgesForSquare x y =
        [ (x,y), (x+1,y);
          (x,y), (x,y+1);
          (x+1,y), (x+1,y+1);
          (x,y+1), (x+1,y+1) ]

    let private constraintForNode length width x y =
        (edgesForNode length width x y), (fun l -> let s = List.sum l in s = 0 || s = 2)

    let private constraintsForNodes length width =
        [ for x in 0 .. length do for y in 0 .. width do yield (x,y) ] |>
        List.map (fun (x,y) -> constraintForNode length width x y)

    let private constraintForSquare x y (v: int) =
        (edgesForSquare x y), (fun l -> let s = List.sum l in s = v)

    let private domains length width = keys length width |> List.map (fun k -> (k, domain)) |> Map.ofList

    let private constraints length width squares =
        squares |> 
        List.map (fun ((x,y), v) -> constraintForSquare x y v) |>
        List.append (constraintsForNodes length width)

    type private Components = { Map: Map<int*int, int>; Circles: int; Components: int; NextId: int }

    let private emptyComponents = { Map = Map.empty; Circles = 0; Components = 0; NextId = 1 }

    let private updateComponents (p,q) value components =
        if value = 0 then components
        else match (Map.tryFind p components.Map, Map.tryFind q components.Map) with
                | None, None ->
                    let c = components.NextId
                    let map = components.Map |> Map.add p c |> Map.add q c
                    { Map = map; Circles = components.Circles; Components = components.Components + 1;  NextId = c + 1 }
                | Some c, None ->
                    { components with Map = components.Map |> Map.add q c }
                | None, Some c ->
                    { components with Map = components.Map |> Map.add p c }
                | Some c, Some d ->
                    if c = d then { components with Circles = components.Circles + 1 }
                    else
                        let map = components.Map |> Map.map (fun _ e -> if e = d then c else e)
                        { components with Map = map; Components = components.Components - 1 }

    let private checkComponents components = components.Circles = 0 || components.Components = 1

    /// Finds all solutions for a slither link puzzle.
    let solve length width squares =
        let ds = domains length width
        let cs = constraints length width squares
        solve emptyComponents updateComponents checkComponents ds cs

    /// Finds one solution for a slither link puzzle.
    let find length width squares = solve length width squares |> CSP.Utils.SeqUtils.safeHead

    let private print length width squares solution =
        printfn ""
        let value x y = squares |> List.tryFind (fun ((a,b),c) -> a = x && b = y) |> Option.map snd
        let printHorizontalEdge x y = if Map.find ((x,y),(x+1,y)) solution = 0 then printf "*   " else printf "*---"
        let printTopRow y = 
            [0 .. (length - 1)] |> List.iter (fun x -> printHorizontalEdge x y)
            printfn "*"
        let printVerticalEdge x y = if Map.find ((x,y),(x,y+1)) solution = 0 then printf "  " else printf "| "
        let printCenterSquare x y = 
            printVerticalEdge x y
            let v = value x y
            if v.IsSome then printf "%d " v.Value else printf "  "
        let printCenterRow y =
            [0 .. length] |> List.iter (fun x -> printCenterSquare x y)
            printfn ""
        let printSquares y =
            printTopRow y
            printCenterRow y
        [0 .. (width - 1)] |> List.iter printSquares
        printTopRow width
        printfn ""

    /// Prints all solutions for a slither link puzzle.
    let solveAndPrint length width squares =
        let solutions = solve length width squares |> List.ofSeq
        solutions |> List.iter (print length width squares)
        solutions

    /// Prints one solution for a slither link puzzle.
    let findAndPrint length width squares =
        match find length width squares with
            | None -> 
                printfn "No solution!"
                None
            | Some s -> 
                print length width squares s
                Some s